home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / cmpnew / cmpif.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  14.9 KB  |  414 lines
  1. ;;; CMPIF  Conditionals.
  2. ;;;
  3. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  4.  
  5. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  6. ;;
  7. ;; GCL is free software; you can redistribute it and/or modify it under
  8. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11. ;; 
  12. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  13. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  15. ;; License for more details.
  16. ;; 
  17. ;; You should have received a copy of the GNU Library General Public License 
  18. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  19. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  
  22. (in-package 'compiler)
  23.  
  24. (si:putprop 'if 'c1if 'c1special)
  25. (si:putprop 'if 'c2if 'c2)
  26. (si:putprop 'and 'c1and 'c1)
  27. (si:putprop 'and 'c2and 'c2)
  28. (si:putprop 'or 'c1or 'c1)
  29. (si:putprop 'or 'c2or 'c2)
  30.  
  31. (si:putprop 'jump-true 'set-jump-true 'set-loc)
  32. (si:putprop 'jump-false 'set-jump-false 'set-loc)
  33.  
  34. (si:putprop 'case 'c1case 'c1)
  35. (si:putprop 'ecase 'c1ecase 'c1)
  36. (si:putprop 'case 'c2case 'c2)
  37.  
  38. (defun c1if (args &aux info f)
  39.   (when (or (endp args) (endp (cdr args)))
  40.         (too-few-args 'if 2 (length args)))
  41.   (unless (or (endp (cddr args)) (endp (cdddr args)))
  42.           (too-many-args 'if 3 (length args)))
  43.   (setq f (c1fmla-constant (car args)))
  44.  
  45.   (case f
  46.         ((t) (c1expr (cadr args)))
  47.         ((nil) (if (endp (cddr args)) (c1nil) (c1expr (caddr args))))
  48.         (otherwise
  49.          (setq info (make-info))
  50.          (list 'if info
  51.                (c1fmla f info)
  52.                (c1expr* (cadr args) info)
  53.                (if (endp (cddr args)) (c1nil) (c1expr* (caddr args) info)))))
  54.   )
  55.  
  56. (defun c1fmla-constant (fmla &aux f)
  57.   (cond
  58.    ((consp fmla)
  59.     (case (car fmla)
  60.           (and (do ((fl (cdr fmla) (cdr fl)))
  61.                    ((endp fl) t)
  62.                    (declare (object fl))
  63.                    (setq f (c1fmla-constant (car fl)))
  64.                    (case f
  65.                          ((t))
  66.                          ((nil) (return nil))
  67.                          (t (if (endp (cdr fl))
  68.                                 (return f)
  69.                                   (return (list* 'and f (cdr fl))))))))
  70.           (or (do ((fl (cdr fmla) (cdr fl)))
  71.                   ((endp fl) nil)
  72.                   (declare (object fl))
  73.                   (setq f (c1fmla-constant (car fl)))
  74.                   (case f
  75.                         ((t) (return t))
  76.                         ((nil))
  77.                         (t (if (endp (cdr fl))
  78.                                (return f)
  79.                                (return (list* 'or f (cdr fl))))))))
  80.           ((not null)
  81.            (when (endp (cdr fmla)) (too-few-args 'not 1 0))
  82.            (unless (endp (cddr fmla))
  83.                    (too-many-args 'not 1 (length (cdr fmla))))
  84.            (setq f (c1fmla-constant (cadr fmla)))
  85.            (case f
  86.                  ((t) nil)
  87.                  ((nil) t)
  88.                  (t (list 'not f))))
  89.           (t fmla)))
  90.    ((symbolp fmla) (if (constantp fmla)
  91.                        (if (symbol-value fmla) t nil)
  92.                        fmla))
  93.    (t t))
  94.   )
  95.  
  96. (defun c1fmla (fmla info)
  97.   (if (consp fmla)
  98.       (case (car fmla)
  99.             (and (case (length (cdr fmla))
  100.                    (0 (c1t))
  101.                    (1 (c1fmla (cadr fmla) info))
  102.                    (t (cons 'FMLA-AND
  103.                             (mapcar #'(lambda (x) (c1fmla x info))
  104.                                     (cdr fmla))))))
  105.             (or (case (length (cdr fmla))
  106.                    (0 (c1nil))
  107.                    (1 (c1fmla (cadr fmla) info))
  108.                    (t (cons 'FMLA-OR
  109.                             (mapcar #'(lambda (x) (c1fmla x info))
  110.                                     (cdr fmla))))))
  111.             ((not null)
  112.                   (when (endp (cdr fmla)) (too-few-args 'not 1 0))
  113.                   (unless (endp (cddr fmla))
  114.                           (too-many-args 'not 1 (length (cdr fmla))))
  115.                   (list 'FMLA-NOT (c1fmla (cadr fmla) info)))
  116.             (t (c1expr* `(the boolean ,fmla) info)))
  117.       (c1expr* fmla info))
  118.   )
  119.  
  120. (defun c2if (fmla form1 form2
  121.                   &aux (Tlabel (next-label)) Flabel)
  122.   (cond ((and (eq (car form2) 'LOCATION)
  123.               (null (caddr form2))
  124.               (eq *value-to-go* 'TRASH)
  125.                (not (eq *exit* 'RETURN)))
  126.          (let ((exit *exit*)
  127.                (*unwind-exit* (cons Tlabel *unwind-exit*))
  128.                (*exit* Tlabel))
  129.               (CJF fmla Tlabel exit))
  130.          (wt-label Tlabel)
  131.          (c2expr form1))
  132.         (t
  133.          (setq Flabel (next-label))
  134.          (let ((*unwind-exit* (cons Flabel (cons Tlabel *unwind-exit*)))
  135.                (*exit* Tlabel))
  136.               (CJF fmla Tlabel Flabel))
  137.          (wt-label Tlabel)
  138.          (let ((*unwind-exit* (cons 'JUMP *unwind-exit*))) (c2expr form1))
  139.          (wt-label Flabel)
  140.          (c2expr form2)))
  141.   )
  142.  
  143. ;;; If fmla is true, jump to Tlabel.  If false, do nothing.
  144. (defun CJT (fmla Tlabel Flabel)
  145.   (case (car fmla)
  146.     (fmla-and (do ((fs (cdr fmla) (cdr fs)))
  147.                   ((endp (cdr fs))
  148.                    (CJT (car fs) Tlabel Flabel))
  149.                   (declare (object fs))
  150.                   (let* ((label (next-label))
  151.                          (*unwind-exit* (cons label *unwind-exit*)))
  152.                         (CJF (car fs) label Flabel)
  153.                         (wt-label label))))
  154.     (fmla-or (do ((fs (cdr fmla) (cdr fs)))
  155.                  ((endp (cdr fs))
  156.                   (CJT (car fs) Tlabel Flabel))
  157.                  (declare (object fs))
  158.                  (let* ((label (next-label))
  159.                         (*unwind-exit* (cons label *unwind-exit*)))
  160.                        (CJT (car fs) Tlabel label)
  161.                        (wt-label label))))
  162.     (fmla-not (CJF (cadr fmla) Flabel Tlabel))
  163.     (LOCATION
  164.      (case (caddr fmla)
  165.            ((t) (unwind-no-exit Tlabel) (wt-nl) (wt-go Tlabel))
  166.            ((nil))
  167.            (t (let ((*value-to-go* (list 'jump-true Tlabel)))
  168.                    (c2expr* fmla)))))
  169.     (t (let ((*value-to-go* (list 'jump-true Tlabel))) (c2expr* fmla))))
  170.   )
  171.  
  172. ;;; If fmla is false, jump to Flabel.  If true, do nothing.
  173. (defun CJF (fmla Tlabel Flabel)
  174.   (case (car fmla)
  175.     (FMLA-AND (do ((fs (cdr fmla) (cdr fs)))
  176.                   ((endp (cdr fs)) (CJF (car fs) Tlabel Flabel))
  177.                   (declare (object fs))
  178.                   (let* ((label (next-label))
  179.                          (*unwind-exit* (cons label *unwind-exit*)))
  180.                         (CJF (car fs) label Flabel)
  181.                         (wt-label label))))
  182.     (FMLA-OR (do ((fs (cdr fmla) (cdr fs)))
  183.                  ((endp (cdr fs)) (CJF (car fs) Tlabel Flabel))
  184.                  (declare (object fs))
  185.                  (let* ((label (next-label))
  186.                         (*unwind-exit* (cons label *unwind-exit*)))
  187.                        (CJT (car fs) Tlabel label)
  188.                        (wt-label label))))
  189.     (FMLA-NOT (CJT (cadr fmla) Flabel Tlabel))
  190.     (LOCATION
  191.      (case (caddr fmla)
  192.            ((t))
  193.            ((nil) (unwind-no-exit Flabel) (wt-nl) (wt-go Flabel))
  194.            (t (let ((*value-to-go* (list 'jump-false Flabel)))
  195.                    (c2expr* fmla)))))
  196.     (t (let ((*value-to-go* (list 'jump-false Flabel))) (c2expr* fmla))))
  197.   )
  198.  
  199. (defun c1and (args)
  200.   (cond ((endp args) (c1t))
  201.         ((endp (cdr args)) (c1expr (car args)))
  202.         (t (let ((info (make-info))) (list 'AND info (c1args args info))))))
  203.  
  204. (defun c2and (forms)
  205.   (do ((forms forms (cdr forms)))
  206.       ((endp (cdr forms))
  207.        (c2expr (car forms)))
  208.       (declare (object forms))
  209.       (cond ((eq (caar forms) 'LOCATION)
  210.              (case (caddar forms)
  211.                    ((t))
  212.                    ((nil) (unwind-exit nil 'JUMP))
  213.                    (t (wt-nl "if(" (caddar forms) "==Cnil){")
  214.                       (unwind-exit nil 'JUMP) (wt "}")
  215.                       )))
  216.             ((eq (caar forms) 'VAR)
  217.              (wt-nl "if(")
  218.              (wt-var (car (caddar forms)) (cadr (caddar forms)))
  219.              (wt "==Cnil){")
  220.              (unwind-exit nil 'jump) (wt "}"))
  221.             (t
  222.              (let* ((label (next-label))
  223.                     (*unwind-exit* (cons label *unwind-exit*)))
  224.                    (let ((*value-to-go* (list 'jump-true label)))
  225.                         (c2expr* (car forms)))
  226.                    (unwind-exit nil 'jump)
  227.                    (wt-label label))))
  228.       ))
  229.  
  230. (defun c1or (args)
  231.   (cond ((endp args) (c1nil))
  232.         ((endp (cdr args)) (c1expr (car args)))
  233.         (t (let ((info (make-info)))
  234.                 (list 'OR info (c1args args info))))))
  235.  
  236. (defun c2or (forms &aux (*vs* *vs*) temp)
  237.   (do ((forms forms (cdr forms))
  238.        )
  239.       ((endp (cdr forms))
  240.        (c2expr (car forms)))
  241.       (declare (object forms))
  242.       (cond ((eq (caar forms) 'LOCATION)
  243.              (case (caddar forms)
  244.                    ((t) (unwind-exit t 'JUMP))
  245.                    ((nil))
  246.                    (t (wt-nl "if(" (caddar forms) "!=Cnil){")
  247.                       (unwind-exit (caddar forms) 'JUMP) (wt "}"))))
  248.             ((eq (caar forms) 'VAR)
  249.              (wt-nl "if(")
  250.              (wt-var (car (caddar forms)) (cadr (caddar forms)))
  251.              (wt "!=Cnil){")
  252.              (unwind-exit (cons 'VAR (caddar forms)) 'jump) (wt "}"))
  253.             ((and (eq (caar forms) 'CALL-GLOBAL)
  254.                   (get (caddar forms) 'predicate))
  255.              (let* ((label (next-label))
  256.                     (*unwind-exit* (cons label *unwind-exit*)))
  257.                    (let ((*value-to-go* (list 'jump-false label)))
  258.                         (c2expr* (car forms)))
  259.                    (unwind-exit t 'jump)
  260.                    (wt-label label)))
  261.             (t
  262.              (let* ((label (next-label))
  263.             (*inline-blocks* 0)
  264.                     (*unwind-exit* (cons label *unwind-exit*)))
  265.                (setq temp (wt-c-push))
  266.                    (let ((*value-to-go* temp)) (c2expr* (car forms)))
  267.                    (wt-nl "if(" temp "==Cnil)") (wt-go label)
  268.                    (unwind-exit temp 'jump)
  269.                    (wt-label label)
  270.            (close-inline-blocks)
  271.            )))
  272.       )
  273.   )
  274.  
  275. (defun set-jump-true (loc label)
  276.   (unless (null loc)
  277.     (cond ((eq loc t))
  278.           ((and (consp loc) (eq (car loc) 'INLINE-COND))
  279.            (wt-nl "if(")
  280.            (wt-inline-loc (caddr loc) (cadddr loc))
  281.            (wt ")"))
  282.           (t (wt-nl "if((" loc ")!=Cnil)")))
  283.     (unless (eq loc t) (wt "{"))
  284.     (unwind-no-exit label)
  285.     (wt-nl) (wt-go label)
  286.     (unless (eq loc t) (wt "}")))
  287.   )
  288.  
  289. (defun set-jump-false (loc label)
  290.   (unless (eq loc t)
  291.     (cond ((null loc))
  292.           ((and (consp loc) (eq (car loc) 'INLINE-COND))
  293.            (wt-nl "if(!(")
  294.            (wt-inline-loc (caddr loc) (cadddr loc))
  295.            (wt "))"))
  296.           (t (wt-nl "if((" loc ")==Cnil)")))
  297.     (unless (null loc) (wt "{"))
  298.     (unwind-no-exit label)
  299.     (wt-nl) (wt-go label)
  300.     (unless (null loc) (wt "}")))
  301.   )
  302.  
  303. (defun c1ecase (args) (c1case args t))  
  304.  
  305. ;;If the key is declared fixnum, then we convert a case statement to a switch,
  306. ;;so that we may see the benefit of a table jump.
  307.  
  308. (defun convert-case-to-switch (args default)
  309.   (let ((sym (gensym)) body keys)
  310.     (dolist (v (cdr args))
  311.         (cond ((si::fixnump (car v)) (push  (car v) body))
  312.           ((consp (car v))(dolist (w (car v)) (push w body)))
  313.           ((member (car v) '(t otherwise))
  314.            (and default
  315.             (cmperror "T or otherwise found in an ecase"))
  316.            (push t body)))
  317.         (push `(return-from ,sym (progn ,@ (cdr v))) body))
  318.     (cond (default (push t body)
  319.         (dolist (v (cdr args))
  320.             (cond ((atom (car v)) (push (car v) keys))
  321.               (t (setq keys (append (car v) keys)))))
  322.         (push `(error "The key ~a for ECASE was not found in cases ~a"
  323.               ,(car args) ',keys)
  324.           body)))
  325.     `(block ,sym (si::switch ,(car args) ,@ (nreverse body)))))
  326.         
  327.           
  328.  
  329. (defun c1case (args &optional (default nil))
  330.   (when (endp args) (too-few-args 'case 1 0))
  331.   (let* ((info (make-info))
  332.          (key-form (c1expr* (car args) info))
  333.          (clauses nil))
  334.     (cond ((subtypep (info-type (second key-form)) 'fixnum)
  335.        (return-from c1case  (c1expr (convert-case-to-switch
  336.                  args default )))))
  337.     (dolist (clause (cdr args))
  338.       (cmpck (endp clause) "The CASE clause ~S is illegal." clause)
  339.       (case (car clause)
  340.             ((nil))
  341.             ((t otherwise)
  342.              (when default
  343.                    (cmperr (if (eq default 't)
  344.                                "ECASE had an OTHERWISE clause."
  345.                                "CASE had more than one OTHERWISE clauses.")))
  346.              (setq default (c1progn (cdr clause)))
  347.              (add-info info (cadr default)))
  348.             (t (let* ((keylist
  349.                        (cond ((consp (car clause))
  350.                               (mapcar #'(lambda (key) (if (symbolp key) key
  351.                                                           (add-object key)))
  352.                                       (car clause)))
  353.                              ((symbolp (car clause)) (list (car clause)))
  354.                              (t (list (add-object (car clause))))))
  355.                       (body (c1progn (cdr clause))))
  356.                  (add-info info (cadr body))
  357.                  (push (cons keylist body) clauses)))))
  358.     (list 'case info key-form (reverse clauses) (or default (c1nil)))))
  359.  
  360. (defun c2case (key-form clauses default
  361.                &aux (cvar (next-cvar)) (*vs* *vs*) (*inline-blocks* 0))
  362.   (setq key-form (car (inline-args (list key-form) '(t))))
  363.   (wt-nl "{object V" cvar "= " key-form ";")
  364.  
  365.   (dolist (clause clauses)
  366.     (let* ((label (next-label))
  367.            (keylist (car clause))
  368.            (local-label nil))
  369.       (do ()
  370.           ((<= (length keylist) 5))
  371.         (when (null local-label) (setq local-label (next-label)))
  372.         (wt-nl "if(")
  373.         (dotimes (i 5)
  374.           (cond ((symbolp (car keylist))
  375.                  (wt "(V" cvar "== ")
  376.                  (case (car keylist)
  377.                    ((t) (wt "Ct"))
  378.                    ((nil) (wt "Cnil"))
  379.                    (otherwise (wt "VV[" (add-symbol (car keylist)) "]")))
  380.                  (wt ")"))
  381.                 (t (wt "eql(V" cvar ",VV[" (car keylist) "])")))
  382.           (when (< i 4) (wt-nl "|| "))
  383.           (pop keylist))
  384.         (wt ")")
  385.         (wt-go local-label))
  386.  
  387.       (wt-nl "if(")
  388.       (do ()
  389.           ((endp keylist))
  390.         (cond ((symbolp (car keylist))
  391.                (wt "(V" cvar "!= ")
  392.                (case (car keylist)
  393.                  ((t) (wt "Ct"))
  394.                  ((nil) (wt "Cnil"))
  395.                  (otherwise (wt "VV[" (add-symbol (car keylist)) "]")))
  396.                (wt ")"))
  397.               (t (wt "!eql(V" cvar ",VV[" (car keylist) "])")))
  398.         (unless (endp (cdr keylist)) (wt-nl "&& "))
  399.         (pop keylist))
  400.       (wt ")")
  401.       (wt-go label)
  402.       (when local-label (wt-label local-label))
  403.       (let ((*unwind-exit* (cons 'JUMP *unwind-exit*))) (c2expr (cdr clause)))
  404.       (wt-label label)))
  405.  
  406.   (if (eq default 't)
  407.       (wt-nl "FEerror(\"The ECASE key value ~s is illegal.\",1,V" cvar ");")
  408.       (c2expr default))
  409.  
  410.   (wt "}")
  411.   (close-inline-blocks))
  412.  
  413.  
  414.